Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue45/Message/SpyEngine.pas

Pascal/Delphi Source File | 2000-11-02 | 16.5 KB | 576 lines

unit SpyEngine;

interface

uses
  SysUtils, Classes, Controls, Messages, Windows, ExtCtrls, StdCtrls,
  Forms, DsgnIntf, MessageDict, SpyViewer;

type

  TFormattedMsgType = (fmtNotApplicable, fmtDispatch, fmtWndProc);
  THookType = (htDispatch, htWndProc, htBoth);
  TMessageType = (mtWindowsMessage, mtCM_Message, mtCN_Message);
  TMessageTypes = set of TMessageType;

  TMessageReceiptEvent = procedure(AControl: TControl;
      const Msg: TMessage; HookType: THookType; Lines: TStrings;
      var Filter: Boolean) of Object;

  TMessageSpy = class(TCustomPanel)
  private
    FHookee:              TControl;
    FHookType:            THookType;
    FMessageTypes:        TMessageTypes;
    FFilterHeavyHitters:  Boolean;
    FFilterConsecutiveMessages:
                          Boolean;
    FOnMessageReceipt:    TMessageReceiptEvent;
    AButton:              TButton;
    LastMsgDWM:           Word;
    LastMsgDCM:           Word;
    LastMsgDCN:           Word;
    LastMsgWPWM:          Word;
    LastMsgWPCM:          Word;
    LastMsgWPCN:          Word;
    Viewer:               TfrmSpyViewer;
    procedure AButtonClick(Sender: TObject);
    procedure DispatchMessage(const Message);
    function DisplayMessage(HT: THookType; const Message): Boolean;
    function FormattedMessage(MsgType: TFormattedMsgType; const Msg): String;
    procedure HookeeDestructing(Sender: TObject);
    procedure HookerEngaged(Engaged: Boolean);
    function DuplicateMessage(HT: THookType; const Message): Boolean;
    procedure ViewerClosing(Sender: TObject; var Action: TCloseAction);
    procedure WndProcMessage(const Message: TMessage);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetHookActive(Active: Boolean);
    property Hookee: TControl read FHookee write FHookee;
  published
    property HookType: THookType read FHookType write FHookType
        default htWndProc;
    property MessageTypes: TMessageTypes read FMessageTypes
        write FMessageTypes default [mtCM_Message, mtCN_Message];
    property FilterHeavyHitters: Boolean read FFilterHeavyHitters
        write FFilterHeavyHitters default True;
    property FilterConsecutiveMessages: Boolean
        read FFilterConsecutiveMessages
        write FFilterConsecutiveMessages default False;
    property Align;
    property Alignment;
    property AutoSize;
    property Constraints;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnMessageReceipt: TMessageReceiptEvent
        read FOnMessageReceipt write FOnMessageReceipt;
  end;

procedure Register;

implementation

type
  PPointer = ^Pointer;

  EHookerError = class(Exception);

  TDispatchMethod = procedure(var Message) of Object;
  TFreeInstanceMethod = procedure of Object;
  TWndProcMethod = procedure(var Message: TMessage) of Object;

  TDispatchMessageEvent = procedure(const Message) of Object;
  TWndProcMessageEvent = procedure(const Message: TMessage) of Object;
  THookeeDestructing = TNotifyEvent;

// ---- THooker ----------------------------------------------------

  THooker = class(TControl)
  private
    Hookee:                 TControl;
    OnDispatchMessage:      TDispatchMessageEvent;
    OnWndProcMessage:       TWndProcMessageEvent;
    OnHookeeDestructing:    TNotifyEvent;
    ClientList:             TList;
    TrueDispatchMethod:     TDispatchMethod;
    TrueFreeInstanceMethod: TFreeInstanceMethod;
    TrueWndProcMethod:      TWndProcMethod;
    procedure DispatchHook(var Message);
    function DispatchVMTAddr(AControl: TControl): Pointer;
    procedure FreeInstanceHook;
    function FreeInstanceVMTAddr(AControl: TControl): Pointer;
    procedure HookDispatchMethod(AControl: TControl);
    procedure HookFreeInstanceMethod(AControl: TControl);
    procedure HookWndProcMethod(AControl: TControl);
    procedure SetHookee(AControl: TControl);
    procedure UnhookDispatchMethod;
    procedure UnhookFreeInstanceMethod;
    procedure UnhookWndProcMethod;
    procedure WndProcHook(var Message: TMessage);
    function WndProcIsHooked(AControl: TControl): Boolean;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    class procedure AttachSpy(MS: TMessageSpy);
    procedure HookControl(MS: TMessageSpy; AControl: TControl;
        ParamOnWndProcMessage: TWndProcMessageEvent;
        ParamOnDispatchMessage: TDispatchMessageEvent;
        ParamOnHookeeDestructing: TNotifyEvent);
    procedure DetachSpy(MS: TMessageSpy);
    procedure UnhookControl;
    procedure ViewerShowing(Showing: Boolean);
  end;

var
  Hooker: THooker;
  MsgDict: TMessageDict;

// ---- TMessageSpy ------------------------------------------------

procedure TMessageSpy.AButtonClick(Sender: TObject);
begin
  Viewer := TfrmSpyViewer.Create(Self);
  Viewer.OnClose := ViewerClosing;
  Hooker.ViewerShowing(True);
  Viewer.Show;
end;

constructor TMessageSpy.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHookType := htWndProc;
  FMessageTypes := [mtCM_Message, mtCN_Message];
  FFilterHeavyHitters := True;
  FFilterConsecutiveMessages := False;
  SetBounds(Left, Top, 85, 25);
  if csDesigning in ComponentState then
    Caption := 'Message Spy'
  else
  begin
    BorderStyle := bsNone;
    AButton := TButton.Create(nil);
    AButton.Parent := Self;
    AButton.Align := alClient;
    AButton.Parent := Self;
    AButton.Caption := 'Message Spy';
    AButton.OnClick := AButtonClick;
    THooker.AttachSpy(Self);
  end;
end;

destructor TMessageSpy.Destroy;
begin
  if Viewer <> nil then
    Viewer.btnClose.Click;
  if Hooker <> nil then
    Hooker.DetachSpy(Self);
  AButton.Free;
  inherited Destroy;
end;

procedure TMessageSpy.DispatchMessage(const Message);
var
  FMT: TFormattedMsgType;
begin
  if (FHookType <> htWndProc) and DisplayMessage(htDispatch, Message) then
  begin
    if FHookType = htBoth then
      FMT := fmtDispatch
    else
      FMT := fmtNotApplicable;
    Viewer.AddLine(FormattedMessage(FMT, Message));
  end;
end;

function TMessageSpy.DisplayMessage(HT: THookType; const Message): Boolean;
var
  Msg:  Word;
  Filter: Boolean;
begin
  Msg := Word(Message);
  Result := ((mtWindowsMessage in FMessageTypes) and (Msg < CM_BASE)) or
      ((mtCM_Message in FMessageTypes) and
          (Msg >= CM_Base) and (Msg < CN_Base)) or
      ((mtCN_Message in FMessageTypes) and
          (Msg >= CN_BASE));
  if not Result then
    Exit;
  if FFilterHeavyHitters then
    Result := not ((Msg = WM_NCHITTEST) or
        (Msg = WM_SETCURSOR) or
        (Msg = WM_MOUSEMOVE) or
        (Msg = CM_HITTEST));
  if Result and FFilterConsecutiveMessages then
    Result := not DuplicateMessage(HT, Message);
  if Result and Assigned(FOnMessageReceipt) then
  begin
    Filter := False;
    FOnMessageReceipt(Hookee, TMessage(Message), HT,
        Viewer.reMessages.Lines, Filter);
    Result := not Filter;
  end;
end;

function TMessageSpy.DuplicateMessage(HT: THookType; const Message): Boolean;
var
  Msg: Word;
begin
  Msg := Word(Message);
  if HT = htDispatch then
  begin
    if Msg < CM_BASE then
    begin
      Result := Msg = LastMsgDWM;
      LastMsgDWM := Msg;
    end
    else if Msg >= CN_BASE then
    begin
      Result := Msg = LastMsgDCN;
      LastMsgDCN := Msg;
    end
    else
    begin
      Result := Msg = LastMsgDCM;
      LastMsgDCM := Msg;
    end;
  end
  else
  begin
    if Msg < CM_BASE then
    begin
      Result := Msg = LastMsgWPWM;
      LastMsgWPWM := Msg;
    end
    else if Msg >= CN_BASE then
    begin
      Result := Msg = LastMsgWPCN;
      LastMsgWPCN := Msg;
    end
    else
    begin
      Result := Msg = LastMsgWPCM;
      LastMsgWPCM := Msg;
    end;
  end;
end;

function TMessageSpy.FormattedMessage(MsgType: TFormattedMsgType;
    const Msg): String;
var
  Prfx: String[2];
begin
  case MsgType of
    fmtDispatch: Prfx := 'D ';
    fmtWndProc:  Prfx := 'W ';
  else
    Prfx := '';
  end;
  Result := Prfx +
      MsgDict.MessageName(TMessage(Msg).Msg) + ' ' +
      IntToHex(TMessage(Msg).WParamHi, 4) + ' ' +
      IntToHex(TMessage(Msg).WParamLo, 4) + ' ' +
      IntToHex(TMessage(Msg).LParamHi, 4) + ' ' +
      IntToHex(TMessage(Msg).LParamLo, 4) + ' ';
end;

procedure TMessageSpy.HookeeDestructing(Sender: TObject);
begin
  Hooker.UnhookControl;
  Hookee := nil;
  Viewer.Spying := False;
end;

procedure TMessageSpy.HookerEngaged(Engaged: Boolean);
begin
  AButton.Enabled := not Engaged;
end;

procedure TMessageSpy.SetHookActive(Active: Boolean);
begin
  if Active then
    Hooker.HookControl(Self, FHookee, WndProcMessage, DispatchMessage,
      HookeeDestructing)
  else
    Hooker.UnhookControl;
  LastMsgDWM := $FFFF;
  LastMsgDCM := $FFFF;
  LastMsgDCN := $FFFF;
  LastMsgWPWM := $FFFF;
  LastMsgWPCM := $FFFF;
  LastMsgWPCN := $FFFF;
end;

procedure TMessageSpy.ViewerClosing(Sender: TObject;
  var Action: TCloseAction);
begin
  Hooker.ViewerShowing(False);
  SetHookActive(False);
  Action := caFree;
  Viewer := nil;
end;

procedure TMessageSpy.WndProcMessage(const Message: TMessage);
var
  FMT: TFormattedMsgType;
begin
  if (FHookType <> htDispatch) and DisplayMessage(htWndProc, Message) then
  begin
    if FHookType = htBoth then
      FMT := fmtWndProc
    else
      FMT := fmtNotApplicable;
    Viewer.AddLine(FormattedMessage(FMT, Message));
  end;
end;

// ---- THooker ----------------------------------------------------

class procedure THooker.AttachSpy(MS: TMessageSpy);
begin
  if Hooker = nil then
  begin
    Hooker := THooker.Create(nil);
    MsgDict := TMessageDict.Create;
  end;
  Hooker.ClientList.Add(MS);
end;

constructor THooker.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ClientList := TList.Create;
end;

destructor THooker.Destroy;
begin
  ClientList.Free;
  inherited Destroy;
end;

procedure THooker.DetachSpy(MS: TMessageSpy);
begin
  ClientList.Remove(MS);
end;

procedure THooker.DispatchHook(var Message);
begin
  // if Self is the Hookee then fire the dispatch message event
  if (Hooker.Hookee = Self) and
      Assigned(Hooker.OnDispatchMessage) then
    Hooker.OnDispatchMessage(Message);
  // set the true dispatch method's object reference to the "self"
  // passed in to this method
  TMethod(Hooker.TrueDispatchMethod).Data := Self;
  Hooker.TrueDispatchMethod(Message);
end;

function THooker.DispatchVMTAddr(AControl: TControl): Pointer;
begin
  // get address of AControl's class's MVT
  Result := Pointer(Pointer(AControl)^);
  // subract offset of Dispatch to the pointer
  Inc(PChar(Result), vmtDispatch);
end;

procedure THooker.FreeInstanceHook;
begin
  // if Self is the Hookee, then the Hookee is in the process of
  // being destroyed; in such a case, notify the Hooker that it
  // must release its control over the Hookee
  if Hooker.Hookee = Self then
    Hooker.OnHookeeDestructing(Self);
  TMethod(Hooker.TrueFreeInstanceMethod).Data := Self;
  Hooker.TrueFreeInstanceMethod;
end;

function THooker.FreeInstanceVMTAddr(AControl: TControl): Pointer;
begin
  // get address of AControl's class's MVT
  Result := Pointer(Pointer(AControl)^);
  // subract offset of Dispatch to the pointer
  Inc(PChar(Result), vmtFreeInstance);
end;

procedure THooker.HookControl(MS: TMessageSpy; AControl: TControl;
    ParamOnWndProcMessage: TWndProcMessageEvent;
    ParamOnDispatchMessage: TDispatchMessageEvent;
    ParamOnHookeeDestructing: TNotifyEvent);
begin
  if ClientList.IndexOf(MS) = -1 then
    raise EHookerError.Create('HookControl requested by ' +
        'unattached TMessageSpy');
  if Hookee <> nil then
    raise EHookerError.Create('Multiple control hooks requested');
  SetHookee(AControl);
  OnWndProcMessage := ParamOnWndProcMessage;
  OnDispatchMessage := ParamOnDispatchMessage;
  OnHookeeDestructing := ParamOnHookeeDestructing;
end;

procedure THooker.HookDispatchMethod(AControl: TControl);
var
  P:    Pointer;
  M:    TMethod;
  Cnt:  Cardinal;
begin
  // set P to the control's class's VMT address of Dispatch
  P := DispatchVMTAddr(AControl);
  // save it in TrueDispatchMethod
  TMethod(TrueDispatchMethod).Code := Pointer(P^);
  // set the VMT addr of the control's class's MVT Dispatch address
  // to that of our own Dispatch
  TDispatchMethod(M) := DispatchHook;
  WriteProcessMemory(GetCurrentProcess, P, @M.Code,
      SizeOf(Pointer), Cnt);
end;

procedure THooker.HookFreeInstanceMethod(AControl: TControl);
var
  P:    Pointer;
  M:    TMethod;
  Cnt:  Cardinal;
begin
  // set P to the control's class's VMT address of Dispatch
  P := FreeInstanceVMTAddr(AControl);
  // save it in TrueFreeInstanceMethod
  TMethod(TrueFreeInstanceMethod).Code := Pointer(P^);
  // set the VMT addr of the control's class's MVT FreeInstance address
  // to that of our own FreeInstance
  TFreeInstanceMethod(M) := FreeInstanceHook;
  WriteProcessMemory(GetCurrentProcess, P, @M.Code,
      SizeOf(Pointer), Cnt);
end;

procedure THooker.HookWndProcMethod(AControl: TControl);
begin
  if WndProcIsHooked(AControl) then
    raise EHookerError.Create('Cannot attach to control; ' +
        'the control currently has a WindowProc hook active');
  TrueWndProcMethod := AControl.WindowProc;
  AControl.WindowProc := WndProcHook;
end;

procedure THooker.SetHookee(AControl: TControl);
begin
  if AControl <> Hookee then
  begin
    if Hookee <> nil then
    begin
      UnhookFreeInstanceMethod;
      UnhookDispatchMethod;
      UnhookWndProcMethod;
    end
    else
    begin
      HookWndProcMethod(AControl);
      HookDispatchMethod(AControl);
      HookFreeInstanceMethod(AControl);
    end;
    Hooker := Self;
    Hookee := AControl;
  end;
end;

procedure THooker.UnhookControl;
begin
  if Hookee <> nil then
    SetHookee(nil);
end;

procedure THooker.UnhookDispatchMethod;
var
  P:    Pointer;
  M:    TMethod;
  Cnt:  Cardinal;
begin
  // set P to the control's class's VMT address of Dispatch
  P := DispatchVMTAddr(Hookee);
  // restore the true Dispatch method address in that location
  M := TMethod(TrueDispatchMethod);
  WriteProcessMemory(GetCurrentProcess, P, @M.Code,
      SizeOf(Pointer), Cnt);
end;

procedure THooker.UnhookFreeInstanceMethod;
var
  P:    Pointer;
  M:    TMethod;
  Cnt:  Cardinal;
begin
  // set P to the control's class's VMT address of FreeInstance
  P := FreeInstanceVMTAddr(Hookee);
  // restore the true Dispatch method address in that location
  M := TMethod(TrueFreeInstanceMethod);
  WriteProcessMemory(GetCurrentProcess, P, @M.Code,
      SizeOf(Pointer), Cnt);
end;

procedure THooker.UnhookWndProcMethod;
begin
  Hookee.WindowProc := TrueWndProcMethod;
end;

procedure THooker.ViewerShowing(Showing: Boolean);
var
  I: Integer;
begin
  for I := 0 to ClientList.Count - 1 do
    TMessageSpy(ClientList[I]).HookerEngaged(Showing);
end;

procedure THooker.WndProcHook(var Message: TMessage);
begin
  // fire the wndproc message event
  if Assigned(Hooker.OnWndProcMessage) then
    Hooker.OnWndProcMessage(Message);
  Hooker.TrueWndProcMethod(Message);
end;

function THooker.WndProcIsHooked(AControl: TControl): Boolean;
var
  P: PPointer;
  WPPosition: Integer;
  WPMethod: TWndProcMethod;
begin
  // get address of our class's WndProc method by assigning it to
  // the event variable; the first 4 bytes of this is the address
  // we need to find in our class's VMT
  WPMethod := WndProc;
  // get the address of our class's VMT
  P := Pointer(Pointer(Self)^);
  // interate through the VMT until we find the entry that equals
  // that of our WndProc
  while Pointer(TMethod(WPMethod).Code) <> Pointer(P^) do
    Inc(P);
  // the offset result is the address at which our WndProc was found
  // minus the start of our VMT
  WPPosition := (PChar(P) - PChar(Pointer(Self)^)) div 4;
  P := Pointer(Pointer(AControl)^);
  // add offset of WndProc to the pointer; the offset of WndProc will
  // be the same for all TControl derived classes
  Inc(P, WPPosition);
  // finally, check to see if AControl's WindowProc property does not
  // equal that WndProc address in AControl's VMT; if it does not then
  // the control has a WndProc hook active
  Result := (TMethod(AControl.WindowProc).Code <> P^);
end;

// ---- Register ---------------------------------------------------

procedure Register;
begin
  RegisterComponents('Samples', [TMessageSpy]);
end;

initialization

finalization

  Hooker.Free;
  MsgDict.Free;

end.